COMMENT ⊗   VALID 00006 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	space saving version
C00004 00003	ss(recdefn,Recursive function definitions.)
C00007 00004	ss(numbers,Numerical computation.)
C00008 00005	ss(lambda,Lambda expressions and functions with functions as arguments.)
C00010 00006	ss(evaluator,The function eval. )
C00013 ENDMK
C⊗;
;;;space saving version

(DEFUN SUBST# (X Y Z)
  (COND ((ATOM Z) (COND ((EQ Y Z) X) (T Z) ))
	(T ((LAMBDA (Z1 Z2) 
	     (COND ((AND (EQ Z1 (CAR Z)) (EQ Z2 (CDR Z))) Z) (T (CONS Z1 Z2))))
            (SUBST# X Y (CAR Z)) (SUBST# X Y (CDR Z)))) ))


;;; alternate definition like system provides
(DEFUN MEMBER# (X U) 
  (COND ((NULL U) NIL) ((EQUAL X (CAR U)) U) (T (MEMBER# X (CDR U))) ))
;;;(DEFUN MEMBER∨ (X U) (ORLIST (FUNCTION (LAMBDA (Y) (EQUAL X Y))) U))

;;;⊗⊗⊗subexpf[x, y] ← [x = y] ∨ [¬qat y ∧ [subexpf[x, qa y] ∨ subexpf[x, qd y]]]⊗.
(DEFUN SUBEXPF (X Y) 
  (OR (EQUAL X Y) 
      (AND (NOT (ATOM Y)) (OR (SUBEXPF X (CAR Y)) (SUBEXPF X (CDR Y))) )))

;;;ss(recdefn,Recursive function definitions.)

(DEFUN ALT (U) 
  (COND ((OR (NULL U) (NULL (CDR U))) U)	
	(T (CONS (CAR U) (ALT (CDDR U)))) ))


(DEFUN LAST (U) (COND ((NULL (CDR U)) (CAR U)) (T (LAST (CDR U))) ))

(DEFUN SUBST (X Y Z)
  (COND ((ATOM Z) (COND ((EQ Y Z) X) (T Z) ))
	(T (CONS (SUBST X Y (CAR Z)) (SUBST X Y (CDR Z)))) ))

(DEFUN APPEND (U V)
  (COND ((NULL U) V) (T (CONS (CAR U) (APPEND (CDR U) V))) ))

(DEFUN EQUAL (X Y)
  (OR (EQ X Y) 
      (AND (NOT (ATOM X)) 
	   (NOT (ATOM Y)) 
	   (EQUAL (CAR X) (CAR Y)) 
	   (EQUAL (CDR X) (CDR Y)))))

(DEFUN MEMBER (X U) (AND (NOT (NULL U)) (OR (EQUAL X (CAR U)) (MEMBER X (CDR U)))))

(DEFUN REVERSE (U) (REV U NIL))
(DEFUN REV (U V) (COND ((NULL U) V) (T (REV (CDR U) (CONS (CAR U) V))) ))

(DEFUN REVERSE1 (U) 
  (COND ((NULL U) NIL) (T (APPEND (REVERSE1 (CDR U)) (LIST (CAR U)))) ))

(DEFUN FLATTEN (X) (FLAT X NIL))
(DEFUN FLAT (X U) (COND ((ATOM X) (CONS X U)) (T (FLAT (CAR X) (FLAT (CDR X) U))) ))

(DEFUN FRINGE (X) 
  (COND ((ATOM X) (LIST X)) (T (APPEND (FRINGE (CAR X)) (FRINGE (CDR X)))) ))

(DEFUN FACTORIAL (N)
  (COND ((EQUAL N 0) 1) (T (TIMES N (FACTORIAL (SUB1 N)))) ))

(DEFUN GCD (M N)
  (COND ((GREATERP M N) (GCD N M))
	((EQUAL M 0) N)
	(T (GCD (MOD N M) M)) ))

(DEFUN MOD (N M)
  (COND ((LESSP N M) N) (T (MOD (DIFFERENCE N M) M)) ))
;;;ss(numbers,Numerical computation.)

(DEFUN LENGTH (U)
  (COND ((NULL U) 0) (T (ADD1 (LENGTH (CDR U)))) ))

(DEFUN ASSOC (X A)
  (COND ((NULL A) NIL) ((EQ X (CAAR A)) (CAR A)) (T (ASSOC X (CDR A))) ))

(DEFUN NUMVAL (E A)
  (COND ((NUMBERP E) E)
	((ATOM E) (CDR (ASSOC E A))
	((EQ (CAR E) 'PLUS) (EVPLUS (CDR E) A))
	((EQ (CAR E) 'TIMES) (EVTIMES (CDR E) A)) ))

(DEFUN EVPLUS (U A)
  (COND ((NULL U) 0) (T (PLUS (NUMVAL (CAR U) A) (EVPLUS (CDR U) A))) ))

(DEFUN EVTIMES (U A)
  (COND ((NULL U) 1) (T (TIMES (NUMVAL (CAR U) A) (EVTIMES (CDR U) A))) ))

;;;ss(lambda,Lambda expressions and functions with functions as arguments.)
(SSTATUS PUNT NIL) 

(DEFUN MAPCAR (F U) (COND ((NULL U) NIL) (T (CONS (F (CAR U)) (MAPCAR F (CDR U)))) ))
(DEFUN MAPLIST (F U) (COND ((NULL U) NIL) (T (CONS (F U) (MAPLIST F (CDR U)))) ))

(DEFUN DIFF (E V) 
  (COND	((ATOM E) (COND ((EQ E V) 1) (T 0)))
	((EQ (CAR E) 'PLUS)
	 (CONS 'PLUS
	       (MAPCAR (FUNCTION (LAMBDA (X) (DIFF X V))) (CDR E))))
	((EQ (CAR E) 'TIMES)
	 (CONS 'PLUS
	       (MAPLIST (FUNCTION 
			  (LAMBDA (X) 
			    (CONS 'TIMES
				  (MAPLIST (FUNCTION 
					    (LAMBDA (Y) 
					      (COND ((EQ X Y) (DIFF (CAR Y) V))
						    (T (CAR Y)))))
					   (CDR E)))))
	                (CDR E))))))


(DEFUN ORLIS (PRED U) 
       (AND (NOT (NULL U)) (OR (PRED (CAR U)) (ORLIS PRED (CDR U))))) 

(DEFUN ANDLIS (PRED U) 
       (OR (NULL U) (AND (PRED (CAR U)) (ANDLIS PRED (CDR U))))) 

(DEFUN ALTLIS (U)
  (MAPCAR (FUNCTION 
	    (LABEL ALT (U) 
	      (COND ((OR (NULL U) (NULL (CDR U))) U) 
		    (T (CONS (CAR U) (ALT (CDDR U)))) )))
	  U) )

;;;ss(evaluator,The function ⊗eval. )
;;;   eval evcond evlist prup see EVALL.LSP[206,LSP]


(DEFUN EVALL (E A) 
  (COND ((ATOM E) 
	  (COND ((NUMBERP E) E) 
		((EQ E T) E)
		((EQ E NIL) E)
		(T (CDR (ASSOC E A)))))
	((ATOM (CAR E))
	  (COND ((EQ (CAR E) 'QUOTE) (CADR E))
		((EQ (CAR E)  'COND) (EVCOND (CDR E) A))
		((EQ (CAR E)  'LIST) (EVLIST (CDR E) A))
		((EQ (CAR E)   'CAR) (CAR (EVALL (CADR E) A)))
		((EQ (CAR E)   'CDR) (CDR (EVALL (CADR E) A)))
		((EQ (CAR E)  'CONS) (CONS (EVALL (CADR E) A) (EVALL (CADDR E) A)))
		((EQ (CAR E)  'ATOM) (ATOM (EVALL (CADR E) A)))
		((EQ (CAR E)    'EQ) (EQ (EVALL (CADR E) A) (EVALL (CADDR E) A)))
		(T  (EVALL (CONS (CDR (ASSOC (CAR E) A)) (CDR E)) A))))
	(T
	  (COND ((EQ (CAAR E) 'LAMBDA) 
		  (EVALL (CADDAR E) (PRUP (CADAR E) (EVLIST (CDR E) A) A)))
	        ((EQ (CAAR E) 'LABEL) 
		  (EVALL (CONS (CADDAR E) (CDR E)) 
			(CONS (CONS (CADAR E) (CADDAR E)) A)))))))

(DEFUN EVCOND (U A)
  (COND ((NULL U) NIL)
	((EVALL (CAAR U) A) (EVALL (CADAR U) A))
	(T (EVCOND (CDR U) A))))

(DEFUN EVLIST (U A)
  (COND ((NULL U) NIL)
	(T (CONS (EVALL (CAR U) A) (EVLIST (CDR U) A)))))

(DEFUN PRUP (U V A)
  (COND ((NULL U) A)
	(T (PRUP (CDR U) (CDR V) (CONS (CONS (CAR U) (CAR V)) A)))))

(DEFUN ASSOC (X U)
  (COND ((NULL U) NIL)
	((EQ (CAAR U) X) (CAR U))
	(T (ASSOC X (CDR U)))))